home *** CD-ROM | disk | FTP | other *** search
/ Aminet 50 / Aminet 50 (2002)(GTI - Schatztruhe)[!][Aug 2002].iso / Aminet / dev / gui / DesignerSource.lha / PasProducer / fonts.pas < prev    next >
Pascal/Delphi Source File  |  1994-09-28  |  2KB  |  92 lines
  1. unit fonts;
  2.  
  3. interface
  4.  
  5. uses utility,layers,gadtools,exec,intuition,dos,routines,liststuff,producerlib,
  6.      amigados,graphics,definitions,iffparse,amiga,asl,workbench;
  7.  
  8. function makemyfont(font:ttextattr):string;
  9. procedure doopendiskfonts;
  10.  
  11. implementation
  12.  
  13. function makemyfont(font:ttextattr):string;
  14. var
  15.   s    : string[100];
  16.   s2   : string[30];
  17.   s3   : string;
  18.   def  : string;
  19.   loop : word;
  20.   notfound : boolean;
  21.   psn      : pstringnode;
  22.   fontname : string;
  23. begin
  24.   ctopas(font.ta_name^,fontname);
  25.   s3:=no0(fontname)+'", ';
  26.   s:='';
  27.   loop:=1;
  28.   while(fontname[loop]<>'.')and(loop<length(fontname))and(fontname[loop]<>#0) do
  29.     begin
  30.       if okchar(fontname[loop]) then
  31.         s:=s+fontname[loop];
  32.       inc(loop);
  33.     end;
  34.   str(font.ta_ysize,s2);
  35.   s3:=s3+s2+', ';
  36.   s:=s+s2;
  37.   str(font.ta_style,s2);
  38.   s:=s+s2;
  39.   s3:=s3+s2+', ';
  40.   str(font.ta_flags,s2);
  41.   s:=s+s2;
  42.   s3:=s3+s2;
  43.   makemyfont:=s;
  44.   notfound:=true;
  45.   def:='  '+s+' : tTextAttr;';
  46.   psn:=pstringnode(varlist.lh_head);
  47.   while(psn^.ln_succ<>nil) do
  48.     begin
  49.       if no0(psn^.st)=def then
  50.         notfound:=false;
  51.       psn:=psn^.ln_succ;
  52.     end;
  53.   if notfound then
  54.     begin
  55.       addline(@opendiskfontlist,s,'');
  56.       addline(@varlist,def,'');
  57.       str(length(no0(fontname))+1,def);
  58.       addline(@constlist,'  '+s+'Name : string['+def+'] = '''+no0(fontname)+'''#0;','');
  59.       addline(@initlist,'  with '+s+' do','');
  60.       addline(@initlist,'    begin','');
  61.       str(font.ta_ysize,s2);
  62.       addline(@initlist,'      '+s+'.ta_YSize:='+s2+';','');
  63.       str(font.ta_flags,s2);
  64.       addline(@initlist,'      '+s+'.ta_Flags:='+s2+';','');
  65.       str(font.ta_style,s2);
  66.       addline(@initlist,'      '+s+'.ta_Style:='+s2+';','');
  67.       addline(@initlist,'      '+s+'.ta_Name:=@'+s+'Name[1];','');
  68.       addline(@initlist,'    end;','');
  69.     end;
  70. end;
  71.  
  72. procedure doopendiskfonts;
  73. var
  74.   psn : pstringnode;
  75. begin
  76.   psn:=pstringnode(opendiskfontlist.lh_head);
  77.   addline(@procfuncdefslist,'Function OpenDiskFonts:Boolean;','');
  78.   addline(@procfunclist,'','');
  79.   addline(@procfunclist,'Function OpenDiskFonts:Boolean;','');
  80.   addline(@procfunclist,'Begin','');
  81.   addline(@procfunclist,'  OpenDiskFonts:=True;','');
  82.   while (psn^.ln_succ<>nil) do
  83.     begin
  84.       addline(@procfunclist,'  if nil = (OpenDiskFont(@'+no0(psn^.st)+')) then','');
  85.       addline(@procfunclist,'    OpenDiskFonts:=False;','');
  86.       psn:=psn^.ln_succ;
  87.     end;
  88.   addline(@procfunclist,'end;','');
  89. end;
  90.  
  91.  
  92. end.